home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / gnu / emacs.lha / emacs-19.16 / lisp / timer.el < prev    next >
Lisp/Scheme  |  1993-06-09  |  6KB  |  145 lines
  1. ;;; timer.el --- run a function with args at some time in future
  2.  
  3. ;; Copyright (C) 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Maintainer: FSF
  6.  
  7. ;; This file is part of GNU Emacs.
  8.  
  9. ;; GNU Emacs is free software; you can redistribute it and/or modify
  10. ;; it under the terms of the GNU General Public License as published by
  11. ;; the Free Software Foundation; either version 2, or (at your option)
  12. ;; any later version.
  13.  
  14. ;; GNU Emacs is distributed in the hope that it will be useful,
  15. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17. ;; GNU General Public License for more details.
  18.  
  19. ;; You should have received a copy of the GNU General Public License
  20. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22.  
  23. ;;; Commentary:
  24.  
  25. ;; This package gives you the capability to run Emacs Lisp commands at
  26. ;; specified times in the future, either as one-shots or periodically.
  27. ;; The single entry point is `run-at-time'.
  28.  
  29. ;;; Code:
  30.  
  31. ;;; The name of the program to run as the timer subprocess.  It should
  32. ;;; be in exec-directory.
  33. (defconst timer-program "timer")
  34.  
  35. (defvar timer-process nil)
  36. (defvar timer-alist ())
  37. (defvar timer-out "")
  38. (defvar timer-dont-exit nil
  39.   ;; this is useful for functions which will be doing their own erratic
  40.   ;; rescheduling or people who otherwise expect to use the process frequently
  41.   "If non-nil, don't exit the timer process when no more events are pending.")
  42.  
  43. ;;;###autoload
  44. (defun run-at-time (time repeat function &rest args)
  45.   "Run a function at a time, and optionally on a regular interval.
  46. Arguments are TIME, REPEAT, FUNCTION &rest ARGS.
  47. TIME, a string, can be specified absolutely or relative to now.
  48. TIME can also be an integer, a number of seconds.
  49. REPEAT, an integer number of seconds, is the interval on which to repeat
  50. the call to the function.  If REPEAT is nil, call it just once.
  51.  
  52. Absolute times may be specified in a wide variety of formats;
  53. Something of the form `HOUR:MIN:SEC TIMEZONE MONTH/DAY/YEAR', where
  54. all fields are numbers, works; the format used by the Unix `date'
  55. command works too.
  56.  
  57. Relative times may be specified as a series of numbers followed by units:
  58.   1 min             denotes one minute from now.
  59.   min            does too.
  60.   1 min 5 sec        denotes 65 seconds from now.
  61.   1 min 2 sec 3 hour 4 day 5 week 6 fortnight 7 month 8 year
  62.             denotes the sum of all the given durations from now."
  63.   (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
  64.   ;; Make TIME a string.
  65.   (if (integerp time)
  66.       (setq time (format "%d sec" time)))
  67.   (cond ((or (not timer-process) 
  68.              (memq (process-status timer-process) '(exit signal nil)))
  69.          (if timer-process (delete-process timer-process))
  70.          (setq timer-process
  71.            (let ((process-connection-type nil))
  72.          ;; Don't search the exec path for the timer program;
  73.          ;; we know exactly which one we want.
  74.          (start-process "timer" nil
  75.                 (expand-file-name timer-program
  76.                           exec-directory)))
  77.                timer-alist nil)
  78.          (set-process-filter   timer-process 'timer-process-filter)
  79.          (set-process-sentinel timer-process 'timer-process-sentinel)
  80.          (process-kill-without-query timer-process))
  81.         ((eq (process-status timer-process) 'stop)
  82.          (continue-process timer-process)))
  83.   ;; There should be a living, breathing timer process now
  84.   (let* ((token (concat (current-time-string) "-" (length timer-alist)))
  85.      (elt (list token repeat function args)))
  86.     (process-send-string timer-process (concat time "@" token "\n"))
  87.     (setq timer-alist (cons elt timer-alist))
  88.     elt))
  89.  
  90. (defun cancel-timer (elt)
  91.   "Cancel a timer previously made with `run-at-time'.
  92. The argument should be a value previously returned by `run-at-time'.
  93. Cancelling the timer means that nothing special 
  94. will happen at the specified time."
  95.   (setcar (cdr elt) nil)
  96.   (setcar (cdr (cdr elt)) 'ignore))
  97.  
  98. (defun timer-process-filter (proc str)
  99.   (setq timer-out (concat timer-out str))
  100.   (let (do token error)
  101.     (while (string-match "\n" timer-out)
  102.       (setq token (substring timer-out 0 (match-beginning 0))
  103.             do (assoc token timer-alist)
  104.             timer-out (substring timer-out (match-end 0)))
  105.       (cond
  106.        (do
  107.     (apply (nth 2 do) (nth 3 do))   ; do it
  108.     (if (natnump (nth 1 do))        ; reschedule it
  109.         (send-string proc (concat (nth 1 do) " sec@" (car do) "\n"))
  110.       (setq timer-alist (delq do timer-alist))))
  111.        ((string-match "timer: \\([^:]+\\): \\([^@]*\\)@\\(.*\\)$" token)
  112.         (setq error (substring token (match-beginning 1) (match-end 1))
  113.               do    (substring token (match-beginning 2) (match-end 2))
  114.               token (assoc (substring token (match-beginning 3) (match-end 3))
  115.                            timer-alist)
  116.               timer-alist (delq token timer-alist))
  117.         (ding 'no-terminate) ; using error function in process filters is rude
  118.         (message "%s for %s; couldn't set at \"%s\"" error (nth 2 token) do))))
  119.     (or timer-alist timer-dont-exit (process-send-eof proc))))
  120.  
  121. (defun timer-process-sentinel (proc str)
  122.   (let ((stat (process-status proc)))
  123.     (if (eq stat 'stop) (continue-process proc)
  124.       ;; if it exited normally, presumably it was intentional.
  125.       ;; if there were no pending events, who cares that it exited?
  126.       (if (or (not timer-alist) (eq stat 'exit)) ()
  127.         (ding 'no-terminate)
  128.         (message "Timer exited abnormally.  All events cancelled."))
  129.       ;; Used to set timer-scratch to "", but nothing uses that var.
  130.       (setq timer-process nil timer-alist nil))))
  131.  
  132. (defun cancel-function-timers (function)
  133.   "Cancel all events scheduled by `run-at-time' which would run FUNCTION."
  134.   (interactive "aCancel timers of function: ")
  135.   (let ((alist timer-alist))
  136.     (while alist
  137.       (if (eq (nth 2 (car alist)) function)
  138.           (setq timer-alist (delq (car alist) timer-alist)))
  139.       (setq alist (cdr alist))))
  140.   (or timer-alist timer-dont-exit (process-send-eof timer-process)))
  141.  
  142. (provide 'timer)
  143.  
  144. ;;; timer.el ends here
  145.